Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE17/THREADS/DBTHREAD.PAS

Pascal/Delphi Source File | 1996-09-11 | 8.2 KB | 258 lines

unit DBThread;
{
  Author : Neil McClements
  Date   : 2nd September 1996
  C/right: (c) 1996 N. McClements
  Purpose: Support for multi-threaded TQuery (using callbacks)
}

interface

uses DB, DBTables, SysUtils,  Dialogs, Windows, cursor;

//
// Define a method pointer type which can be used to return a populated TQuery to a callback procedure
//
  type TCallbackQuery=procedure (qry:TQuery) of object;

//
// Define a wrapper for TDatabase, which adds thread-enabled query methods
//
  type TThreadDatabase=class(TDatabase)
       private
           ThreadsRunning:longint;
           function Password:string;
           function UserName:string;
           function DBName:string;
           function ServerName:string;
           function Driver:string;
           function CreateNewSession(const SessionName:string):TDatabase;
           procedure ThreadDone(Sender:TObject);
       public
           function Connect:boolean;
           function Disconnect:boolean;
           function RunQuery(sql_str:string; var Callback:TCallBackQuery):THandle;
  end;

//
// Define a class to run the query within a thread, returning the result set as
// a populated TQuery via a callback
//
  type TCallbackThread = class(TThread)
       private
           FCallback:TCallBackQuery;
           FQuery: TQuery;
           FSession: TSession;
           FQueryException: Exception;
           FCursor:TSpinningCursor;
           procedure Execute; override;
           procedure ReturnQueryToCallback;
           procedure HandleExceptions;
       public
           constructor Create(Session:TSession; var Query:TQuery; var callback:TCallBackQuery);
  end;

const
   MAX_CONCURRENT_THREADS=10000;               // used as a seed for the random number SessionID generator

implementation

// #############################################################################
// Class  : TThreadDatabase
// Purpose: A TDatabase wrapper class
// Author : Neil McClements
// Date   : 2nd September '96
// #############################################################################


function TThreadDatabase.Password:string;
// Return the password used to connect
begin
    Result:='masterkey';
end;

function TThreadDatabase.UserName:string;
// Return the database login for this user
begin
      Result:='SYSDBA';
end;

function TThreadDatabase.DBName:string;
// Return the name of the database
begin
    Result:='IBLOCAL';
end;

function TThreadDatabase.ServerName:string;
// Return the database file for connection
begin
    Result:='c:\delphi2\IntrBase\EXAMPLES\EMPLOYEE.GDB';
end;

function TThreadDatabase.Driver:string;
// Which driver we use to connect
begin
     Result:='INTRBASE';
end;

function TThreadDatabase.CreateNewSession(const SessionName:string):TDatabase;
var
   tempdb:TDatabase;
   newSession:TSession;
begin
     tempdb:=nil;
     try
       newSession:=Sessions.OpenSession(SessionName);
       with Sessions do
         begin
           with FindSession(Sessionname) do
              Result:=FindDatabase(SessionName);               // this database object exists already - so return it!
           if Result=nil then
             begin
               tempdb:=TDatabase.create(self);
               tempdb.drivername:=Driver;
               tempdb.databasename:=(DBName+SessionName);
               tempdb.sessionname:=SessionName;
               tempdb.keepconnection:=false;
               tempdb.loginprompt:=false;
               tempdb.params.values['DATABASE NAME']:=DBName;
               tempdb.params.values['SERVER NAME']:=ServerName;
               tempdb.params.values['USER NAME']:=UserName;
               tempdb.params.values['PASSWORD']:=Password;
               tempdb.temporary:=true;    // connection perishes when parent is freed
               try
                 tempdb.connected:=true; // try and connect - if there's an error rtn nil
                 Result:=tempdb;
               except
                on e:EDBEngineError do
                   begin
                      tempdb.free;
                      Result:=nil;
                   end;
                end; // except
             end; //if...
         end; // outer with
     except
           tempdb.free;
           Result:=nil;
     end; // try...
end;

procedure TThreadDatabase.ThreadDone(Sender:TObject);
begin
     showmessage('Thread ' + IntToStr((Sender as TThread).ThreadID) + ' finished!');
end;

function TThreadDatabase.Connect:boolean;
// Attempt to connect to the database. When tempdb is nil, the connection process has failed.
// Returns true for successful connection. False indicates failure.
var
   tempdb:TDatabase;
begin
     tempdb:=CreateNewSession('Default'); // NB the first session created will be "Default"
     if (tempdb=nil) then
       Result:=false                   //error
     else
       begin
          Result:=true;                // successful connection
       end;
end;

function TThreadDatabase.Disconnect:boolean;
var
   s:integer;
begin
     try
       for s:=(sessions.count-1) downto 0 do
           sessions[s].Databases[0].close;
       disconnect:=true;
     except
          disconnect:=false;
     end;
end;

function TThreadDatabase.RunQuery(sql_str:string; var Callback:TCallBackQuery):THandle;
var
  NewSession:TSession;
  ThreadQuery:TQuery;
  SessionID:string;
  thread_id:THandle;
  SessionDB:TDatabase;
  Thread:TCallBackThread;
begin

// Use random numbers as a session identifier...
     Randomize;
     SessionID:=IntToStr(Random(MAX_CONCURRENT_THREADS));

// Create a new database, which can then be associated with the new session...
     SessionDB:=CreateNewSession(SessionID);
     NewSession:=Sessions.FindSession(SessionID);
     if NewSession=nil then
       begin
         // there was an error creating the new database & session which wasn't flagged elsewhere - unlikely but...
         showmessage('THREAD SESSION CREATION ERROR');
     halt;
       end;

// Create a new TQuery and connect it to the correct database with the newly created session
     ThreadQuery:=TQuery.Create(Self);
     with ThreadQuery do
       begin
         DatabaseName:=(DBName+SessionID);  //maintain that reference - eg 'IBLOCAL1645'
         SessionName:=SessionID;
         close;
         sql.add(sql_str);
       end; // with

// Kick-off a thread with the session, query and callback procedure passed as parameters to the thread's constructor
     thread:=TCallBackThread.Create(NewSession, ThreadQuery, Callback);
     thread.OnTerminate:=ThreadDone;
     thread_id:=((thread as TThread).threadid);
     Result:= thread_id; // Return the thread id - in case user wants to cancel query, manipulate thread with API etc
end;


// #############################################################################
// Class  : TCallBackThread
// Purpose: Implementation of a TThread-derived threaded query class
// Author : Neil McClements
// Date   : 2nd September '96
// #############################################################################

constructor TCallbackThread.Create(Session:TSession;  var Query:TQuery; var callback:TCallBackQuery);
begin
  inherited Create(true);    // create thread in a suspended state
  Priority:=tpNormal;
  FCursor:=TSpinningCursor.Create;
  FSession:=Session;
  FQuery:=Query;
  FCallback:=callback;
  FreeOnTerminate:=True;
  Resume;                    // initialisation complete so kick-off the thread
end;

procedure TCallbackThread.Execute;
begin
  try
    FQuery.Open;                        // execute the query - this may take some time
    Synchronize(ReturnQueryToCallback); // once the query has finished, return the result set
  except
    FQueryException := ExceptObject as Exception;
    Synchronize(HandleExceptions);
  end;
end;

procedure TCallbackThread.ReturnQueryToCallback;
begin
     FCursor.Terminate;  // zap the cursor thread!
     FCallback(FQuery);  // return the TQuery result set to the callback proc
end;

procedure TCallbackThread.HandleExceptions;
begin
     FCursor.terminate; // zap the cursor thread and report the error
     showmessage('Error running query :' + FQueryException.message);
end;

end.